Night Owl 9/Night Owl CD-ROM (NOPV9) (Night Owl Publisher) (1993).ISO/010a/cliptree.zip/MISC.PRG

Text File | 1993-02-08 | 6KB | 181 lines

/*┌──────────────────────────────────────────────────────────────────────┐
 ▌│                                                                      │
 ▌│ Program Name: MISC.PRG           Purpose.: Various functions         │
 ▌│ Date Created: 02/06/93           Language: Clipper 5.0               │
 ▌│ Time Created: 10:56:24             Author: Kevin S Gallagher         │
 ▌│ PickOne() by: Stephen L. Woolstenhulme                               │
 ▌│                                                                      │
 ▌│                                                                      │
 ▌└──────────────────────────────────────────────────────────────────────┘
 ▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀           */

#include "include1.h"

function BoxShad( nTR, nTC, nBR, nBC, cClrs,nShad )
    local ShadColor := IF( VALTYPE( nShad ) == "N", CHR(nShad), CHR(8) )
    EVAL(                                                              ;
    { | cDefCol | cDefCol:=SETCOLOR( cClrs ),                          ;
    RESTSCREEN( nTR+1, nTC+2, nBR+1, nBC+2,                            ;
    TRANSFORM( SAVESCREEN( nTR+1, nTC+2, nBR+1, nBC+2 ),               ;
    REPLICATE( "X"+ShadColor, ( nBR-nTR+1 ) * ( nBC-nTC+1 ) ) ) ),     ;
    DISPBOX( nTR, nTC, nBR, nBC,"╔═╗║╝═╚║ "),                          ;
    SETCOLOR( cDefCol ) }                                              )
return nil
/*
* Author: Stephen L. Woolstenhulme
*/
function PickOne( cText, aPicks, nRow, nWhich, cColor )
   local nOffSet, nArrayLen, nSpace, nLcol, cScrn, nLen, i
   local getlist := {}
   memvar gcBoxColor
   nOffSet  := len( cText ) / 2 + 2
   nArrayLen:= 0
   nRow     := IF( nRow   == Nil, 21, nRow )
   nWhich   := IF( nWhich == Nil,  1, nWhich )

   if cColor == Nil
       if type( 'gcBoxColor' ) == 'C'
           cColor := gcBoxColor
       else
           cColor := 'w+/r, n/w ,,, w+/n'
       endif
   endif

   nRow := IF( nRow > maxcol() - 1, maxcol() - 1, nRow )
   nRow := IF( nRow < 2, 2, nRow )
   nLen := len( aPicks )

   FOR i := 1 TO nLen
      nArrayLen += len( aPicks[ i ] )
   NEXT

   if nArrayLen + len( aPicks ) - 1 >= len( cText )
      nSpace := 2
   else
      nSpace :=  ( len( cText ) - nArrayLen ) / ( len( aPicks ) + 1 )
   endif

   nLcol  := ( maxcol() / 2 + 1 ) - ;
             ( max( len( cText ), nArrayLen + nSpace * len( aPicks ) ) / 2 )
   cScrn  := savescreen( nRow - 3, 0, nRow + 3, maxcol() )
   cColor := SetColor( cColor )
   /*
   * Steve's code had "Shadow" commented out (didn't include it either)
   * I used a generic shadow udf (see below) so not to add any lib calls
   */
   Shadow( nRow-2, nLcol-2, nRow+1, 81 - nLcol )

   @ nRow - 2, nLcol - 2, nRow + 1, 81 - nLcol box "╔═╗║╝═╚║ "
   @ nRow - 1, ( maxcol() / 2 ) - ( len( cText ) / 2 ) say cText
   nOffSet := ( maxcol() / 2 + 1 ) - ( nArrayLen + ( nSpace * ( len( aPicks ) + 1 ) ) ) / 2
   @ nRow, nOffSet say ""
   nLen := len( aPicks )

   FOR i = 1 TO nLen
      @ nRow, COL() + nSpace prompt aPicks[i]
   next

   menu to nWhich
   setcolor( cColor )
   restscreen( nRow - 3, 0, nRow + 3, maxcol(), cScrn )
return nWhich
/*
* What it does: places a shadow around boxes
*/
Procedure Shadow( nTr, nTc, nBr, nBc,nColor )
    DEFAULT nColor TO 7
    MakeShad( nBr+1, nTc+1, nBr+1, nBc+1,nColor )
    MakeShad( nTr+1, nBc+1, nBr+1, nBc+1,nColor )
Return
STATIC Procedure MakeShad( nTr, nTc, nBr, nBc,nColor )
    local cStrip:= SAVESCREEN( nTr, nTc, nBr, nBc )
    local cTemp := REPLICATE( 'x' +chr(nColor), LEN(cStrip) /2 )
    cStrip      := TRANSFORM( cStrip, cTemp )
    RESTSCREEN( nTr, nTc, nBr, nBc, cStrip )
Return
/*
* Author......: Kevin S. Gallagher
* what it does: shows help at the DOS prompt, called from MAIN()
*/
function CMDHELP(Err)
    local Drv:=""
    if VALTYPE(Err) == "C"
        /*
        * gotta error from the errorsystem
        */
        alert("READ;ERROR.TXT;FOR LIST OF ERRORS",{" QUIT "})
        QUIT
    endif
    setcolor("w/n")
    scroll(0,0,14,80,14)
    Drv := SUBS(curdrive(),1,2)
    @0,0 say PADR("VTREE  by Kevin S. Gallagher",80) color "n/bg"
    DevPos(1,0);DevOut("VTREE ","GR+");DevOut("[","RB+")
    DevOut("drive","W+");DevOut("]","RB+");DevOut(" [","RB+")
    DevOut("/R","W+");DevOut("] [","RB+");DevOut("/W","W+");DevOut("]","RB+")

    @ 2,0 say "[drive]  --> drive to read"
    @ 3,0 say "[/R]     --> re-read disk file"
    @ 4,0 say "[/W]     --> write disk file"
    @ 5,0 say "[/?]     --> this screen"
    @ 6,0 say "Example: Read current log drive "+Drv+" w/o written disk file"
    @ 7,0 say "VTREE [enter]"
    @ 8,0 say "Read drive H: and write disk array"
    @ 9,0 say "VTREE H: /W [enter]"

    @11,0 say "VTREE's disk file also works with my file finder utility"
    @14,0
    quit
return nil
/*
* Author......: Kevin S. Gallagher
* What it does: get the current logged drive
*/
function curdrive
    local nHandle:=0,cBuf:=space(20),cDrv:=""
    run cd >$$$$$$$$.000
    if file("$$$$$$$$.000")
        nHandle:=fopen("$$$$$$$$.000",0)
        if ferror() = 0
            fread(nHandle,@cBuf,20)
            fclose(nHandle)
            ferase("$$$$$$$$.000")
            cDrv:=if("\" $ subs(cBuf,3,1),subs(cBuf,1,3),subs(cBuf,1,2)+"\")
            /*
            * uncomment for full path
            * cdrv += curdir()
            */
        endif
    endif
    cdrv:=upper(cdrv)
return cdrv

#ifdef NEEDME
/*
* inkey as a wait state
*/
function WKEY(nDelay)
    local nKey, cblock
    DO CASE
        CASE pcount() == 0
            nKey := inkey()
        CASE nDelay == NIL .AND. Pcount() == 1
            nKey := inkey(0)
        OTHERWISE
            nKey := inkey(nDelay)
    ENDCASE

    cblock := setkey(nKey)
    IF cblock != NIL
        eval(cblock, Procname(1), Procline(1), NIL)
    ENDIF
RETURN nKey
#endif

function DrvReady( cDrv )
    local nHandle := fopen( cDrv+":\NUL:")
return ( ferror() <> 3 )